home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / tek40.scm < prev    next >
Encoding:
Text File  |  1994-05-23  |  2.7 KB  |  93 lines
  1. ;"tek40.scm", Tektronix 4000 series graphics support in Scheme.
  2. ;Copyright (C) 1992, 1994 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;THIS FILE NEEDS MORE WORK.
  21.  
  22. ;The Tektronix 4000 series graphics protocol gives the user a 1024 by
  23. ;1024 square drawing area.  The origin is in the lower left corner of
  24. ;the screen.  Increasing y is up and increasing x is to the right.
  25.  
  26. ;The graphics control codes are sent over the current-output-port and
  27. ;can be mixed with regular text and ANSI or other terminal control
  28. ;sequences.
  29.  
  30. ;  (tek40:init)                        procedure
  31.  
  32. (define (tek40:init) 'noop)
  33.  
  34. (define esc-string (string (integer->char #o33)))
  35.  
  36. (define tek40:graphics-str
  37.   (string-append
  38.    (string slib:form-feed)
  39.    esc-string  (string (integer->char #o14))
  40.    ;; clear the screen
  41.    ))
  42.  
  43. (define (tek40:graphics) (display tek40:graphics-str) (force-output))
  44.  
  45. (define (tek40:text)
  46.   (tek40:move 0 12)
  47.   (write-char (integer->char #o37)))
  48.  
  49. (define (tek40:linetype linetype)
  50.   (cond ((or (negative? linetype) (> linetype 15))
  51.      (slib:error "bad linetype" linetype))
  52.     (else
  53.      (display esc-string)
  54.      (write-char (integer->char (+ (char->integer #\`) linetype))))))
  55.  
  56. (define (tek40:move x y)
  57.   (write-char (integer->char #o35))
  58.   (tek40:draw x y))
  59.  
  60. (define (tek40:draw x y)
  61.   (display (string
  62.         (integer->char (+ #x20 (quotient y 32)))
  63.         (integer->char (+ #x60 (remainder y 32)))
  64.         (integer->char (+ #x20 (quotient x 32)))
  65.         (integer->char (+ #x40 (remainder x 32))))))
  66.  
  67. (define (tek40:put-text x y str)
  68.   (tek40:move x (+ y -11))
  69.   (write-char (integer->char #o37))
  70.   (display str))
  71.  
  72. (define (tek40:reset) (display tek40:graphics-str) (force-output))
  73.  
  74. (define (tek40:test)
  75.   (tek40:init)
  76. ;  (tek40:reset)
  77.   (tek40:graphics)
  78.   (tek40:linetype 0)
  79.   (tek40:move 100 100)
  80.   (tek40:draw 200 100)
  81.   (tek40:draw 200 200)
  82.   (tek40:draw 100 200)
  83.   (tek40:draw 100 100)
  84.   (do ((i 0 (+ 1 i)))
  85.       ((> i 15))
  86.     (tek40:linetype i)
  87.     (tek40:move (+ (* 50 i) 100) 100)
  88.     (tek40:put-text (+ (* 50 i) 100) 100 (number->string i))
  89.     (tek40:move (+ (* 50 i) 100) 100)
  90.     (tek40:draw (+ (* 50 i) 200) 200))
  91.   (tek40:linetype 0)
  92.   (tek40:text))
  93.